unit UFrameMap;
(*******************************************************************************

*******************************************************************************)

interface

uses
  WinApi.Windows, WinApi.Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, UVonConfig, UVonLog, JPEG;

type
  TArea = class;

  TFrameMap = class(TFrame)
    ScrollBox1: TScrollBox;
    Image1: TImage;
    procedure Image1DblClick(Sender: TObject);
  private
    { Private declarations }
    FList: TList;
    FCanEdit: Boolean;
    FBackgroundFile: TFilename;
    FOnSelected: TNotifyEvent;
    FOnChanged: TNotifyEvent;
    FAutoFreeObj: Boolean;
    procedure SetCanEdit(const Value: Boolean);
    procedure SetBackgroundFile(const Value: TFilename);
    function GetAreas(Index: Integer): TArea;
    procedure SetAreas(Index: Integer; const Value: TArea);
    procedure SetOnSelected(const Value: TNotifyEvent);
    procedure SetOnChanged(const Value: TNotifyEvent);
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function Add(Area: TArea): Integer;
    procedure Insert(Index: Integer; Area: TArea);
    procedure Delete(Index: Integer);
    procedure Clear;
    property Areas[Index: Integer]: TArea read GetAreas write SetAreas;
  published
    property CanEdit: Boolean read FCanEdit write SetCanEdit;
    property AutoFreeObj: Boolean read FAutoFreeObj write FAutoFreeObj;
    property BackgroundFile: TFilename read FBackgroundFile write SetBackgroundFile;
    property OnSelected: TNotifyEvent read FOnSelected write SetOnSelected;
    property OnChanged: TNotifyEvent read FOnChanged write SetOnChanged;
  end;

  TArea = class(TPanel)
  private
    FDown: Boolean;
    FOldX: TPoint;
    FOldY: TPoint;
    ShapeList: Array [1 .. 8] of TShape;
    FRectList: array [1 .. 8] of TRect;
    FPosList: array [1 .. 8] of Integer;
    FSnapSize: Integer;
    FID: Integer;
    FOnChanged: TNotifyEvent;
    FPID: Integer;
    FObj: TObject;
    FCanResize: Boolean;
    procedure WmSize(var Msg: TWmSize); message wm_Size;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure CMExit(var Message: TCMExit); message CM_EXIT;
    procedure aaa(var a: TWMERASEBKGND); message WM_ERASEBKGND;
    procedure WmNcHitTest(var Msg: TWmNcHitTest); message wm_NcHitTest;
    procedure WmLButtonDown(var Msg: TWmLButtonDown); message wm_LButtonDown;
    procedure WmMove(var Msg: TWmMove); message Wm_Move;
    procedure Paint; override;
    procedure SetID(const Value: Integer);
    procedure SetOnChanged(const Value: TNotifyEvent);
    procedure SetPID(const Value: Integer);
    procedure SetObj(const Value: TObject);
    procedure SetCanResize(const Value: Boolean);
  public
    constructor Create(AOwner: TComponent);
    destructor Destroy; override;
  published
    property ID: Integer read FID write SetID;
    property PID: Integer read FPID write SetPID;
    property CanResize: Boolean read FCanResize write SetCanResize;
    property Obj: TObject read FObj write SetObj;
    property OnChanged: TNotifyEvent read FOnChanged write SetOnChanged;
  end;

implementation

{$R *.dfm}

{ TFrameMap }

function TFrameMap.Add(Area: TArea): Integer;
begin
  Area.Parent:= ScrollBox1;
  Area.OnClick:= FOnSelected;
  Area.OnChanged:= FOnChanged;
  Result:= FList.Add(Pointer(Area));
end;

procedure TFrameMap.Clear;
var
  I: Integer;
begin
  for I := 0 to FList.Count - 1 do begin
    if FAutoFreeObj and Assigned(TArea(FList[I]).Obj) then
      TArea(FList[I]).Obj.Free;
    TArea(FList[I]).Free;
  end;
  FList.Clear;
end;

constructor TFrameMap.Create(AOwner: TComponent);
begin
  inherited;
  FList:= TList.Create;
end;

procedure TFrameMap.Delete(Index: Integer);
begin
  if FAutoFreeObj and Assigned(TArea(FList[Index]).Obj) then
    TArea(FList[Index]).Obj.Free;
  TArea(FList[Index]).Free;
  FList.Delete(Index);
end;

destructor TFrameMap.Destroy;
begin
  FList.Free;
  inherited;
end;

function TFrameMap.GetAreas(Index: Integer): TArea;
begin
  Result:= TArea(FList[Index]);
end;

procedure TFrameMap.Image1DblClick(Sender: TObject);
begin
  with TOpenDialog.Create(nil)do try
    if Execute() then
      BackgroundFile:= Filename;
  finally
    Free;
  end;
end;

procedure TFrameMap.Insert(Index: Integer; Area: TArea);
begin
  Area.Parent:= ScrollBox1;
  FList.Insert(Index, Pointer(Area));
end;

procedure TFrameMap.SetAreas(Index: Integer; const Value: TArea);
begin
  TArea(FList[Index]).Free;
  FList[Index]:= Pointer(Value);
end;

procedure TFrameMap.SetBackgroundFile(const Value: TFilename);
begin
  FBackgroundFile := Value;
  if FBackgroundFile <> '' then
    Image1.Picture.LoadFromFile(FBackgroundFile);
end;

procedure TFrameMap.SetCanEdit(const Value: Boolean);
begin
  FCanEdit := Value;
end;

procedure TFrameMap.SetOnChanged(const Value: TNotifyEvent);
var
  I: Integer;
begin
  FOnChanged := Value;
  for I := 0 to FList.Count - 1 do
    TArea(Flist[I]).OnChanged:= FOnChanged;
end;

procedure TFrameMap.SetOnSelected(const Value: TNotifyEvent);
var
  I: Integer;
begin
  FOnSelected := Value;
  for I := 0 to FList.Count - 1 do
    TArea(Flist[I]).OnClick:= FOnSelected;
end;

{ TArea }

constructor TArea.Create(AOwner: TComponent);
var
  I: Integer;
begin
  inherited;
  ShowCaption:= False;
  FullRepaint := False;
  FSnapSize:= 5;
  FPosList[1] := htTopLeft;
  FPosList[2] := htTop;
  FPosList[3] := htTopRight;
  FPosList[4] := htRight;
  FPosList[5] := htBottomRight;
  FPosList[6] := htBottom;
  FPosList[7] := htBottomLeft;
  FPosList[8] := htLeft;
  for I := 1 to 8 do
  begin
    ShapeList[I] := TShape.Create(Self);
    ShapeList[I].Parent := Self;
    ShapeList[I].Brush.Color := not Color;
    ShapeList[I].Visible := False;
  end;
end;

destructor TArea.Destroy;
begin
  inherited;
end;

procedure TArea.aaa(var a: TWMERASEBKGND);
begin

end;

procedure TArea.CMExit(var Message: TCMExit);
begin
  Inherited;
  Paint;
end;

procedure TArea.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited;
  FDown := True;
  FOldX := Point(X, Y);
  SetFocus;
  Paint;
  if Assigned(OnClick) then
    OnClick(self);
end;

procedure TArea.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  NewPoint: TPoint;

  function findnearest(X, Y: Integer): TPoint;
  begin
    Result.X := (X div 5) * 5 + Round((X mod 5) / 5) * 5;
    Result.Y := (Y div 5) * 5 + Round((Y mod 5) / 5) * 5;
  end;

begin
  inherited;
  if FDown then
  begin
    NewPoint := findnearest(Left + X - FOldX.X, Top + Y - FOldX.Y);
    with Self do
      SetBounds(NewPoint.X, NewPoint.Y, Width, height);
    Paint;
  end;
end;

procedure TArea.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  inherited;
  FDown := False;
  if Assigned(FOnChanged) then
    FOnChanged(self);
end;

procedure TArea.Paint;
var
  I, baseH: Integer;
  txtList: TStringList;

  procedure DisplayName(text: string);
  var
    mPos, oPos: Integer;
  begin
    mPos:= 1;
    while(mPos <= Length(text))and(Canvas.TextWidth(Copy(text, 1, mPos)) < Width)do
      Inc(mPos);
    txtList.Add(Copy(text, 1, mPos - 1));
    text:= Copy(text, mPos, MaxInt);
    if text <> '' then DisplayName(text);
  end;
begin
  inherited;
  Left:= Round(Left / FSnapSize * FSnapSize);
  Top:= Round(Top / FSnapSize * FSnapSize);
  Width := Round((BoundsRect.right - BoundsRect.Left) / FSnapSize * FSnapSize);
  Height := Round((BoundsRect.Bottom - BoundsRect.Top) / FSnapSize * FSnapSize);
  Canvas.Lock;
  Canvas.Brush.Color := Self.Color;
  Canvas.Pen.Color := Self.Color;
  Canvas.FillRect(Rect(0, 0, BoundsRect.right, BoundsRect.Bottom));
  if Focused then
  begin
    Canvas.Brush.Color := $FFFFFF - Self.Color;
    Canvas.Pen.Color := $FFFFFF - Self.Color;
  end
  else
  begin
    Canvas.Brush.Color := Self.Color;
    Canvas.Pen.Color := Self.Color;
  end;
  for I := 1 to 8 do
    with FRectList[I] do
      Canvas.RecTangle(Left, Top, right, Bottom);
  Canvas.Unlock;
end;

procedure TArea.SetCanResize(const Value: Boolean);
begin
  FCanResize := Value;
end;

procedure TArea.SetID(const Value: Integer);
begin
  FID := Value;
end;

procedure TArea.SetObj(const Value: TObject);
begin
  FObj := Value;
end;

procedure TArea.SetOnChanged(const Value: TNotifyEvent);
begin
  FOnChanged := Value;
end;

procedure TArea.SetPID(const Value: Integer);
begin
  FPID := Value;
end;

procedure TArea.WmLButtonDown(var Msg: TWmLButtonDown);
begin
  inherited;
end;

procedure TArea.WmMove(var Msg: TWmMove);
var
  R: TRect;
begin
  R := BoundsRect;
  InflateRect(R, -2, -2);
  Paint;
end;

procedure TArea.WmNcHitTest(var Msg: TWmNcHitTest);
var
  Pt: TPoint;
  I: Integer;
begin
  Pt := Point(Msg.XPos, Msg.YPos);
  Pt := ScreenToClient(Pt);
  Msg.Result := 0;
  for I := 1 to 8 do
    if PtInRect(FRectList[I], Pt) then
      Msg.Result := FPosList[I];
  if Msg.Result = 0 then
    inherited;
end;

procedure TArea.WmSize(var Msg: TWmSize);
var
  R: TRect;
begin
  FRectList[1] := Rect(0, 0, 5, 5);
  FRectList[2] := Rect(Width div 2 - 3, 0, Width div 2 + 2, 5);
  FRectList[3] := Rect(Width - 5, 0, Width, 5);
  FRectList[4] := Rect(Width - 5, height div 2 - 3, Width, height div 2 + 2);
  FRectList[5] := Rect(Width - 5, height - 5, Width, height);
  FRectList[6] := Rect(Width div 2 - 3, height - 5, Width div 2 + 2, height);
  FRectList[7] := Rect(0, height - 5, 5, height);
  FRectList[8] := Rect(0, height div 2 - 3, 5, height div 2 + 2);
  Paint;
//  if (not (csLoading in ComponentState))and Assigned(FOnChanged) then
//    FOnChanged(self);
end;

end.
